PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/miscuni.com/PRNUTIL.PAS

Pascal/Delphi Source File | 1989-05-25 | 18.2 KB | 643 lines

{.he Printer Utilities Module - %F}
(**********************************************************************)
(*                        Unit PrnUtil                                *)
(*                                                                    *)
(*                                                                    *)
(*  Author:  Geoffrey W. Moehrke                                      *)
(*  Date:  May 24, 1989                                               *)
(*                                                                    *)
(*  Purpose:  Low & high level printer handling.  Routines to handle  *)
(*            printer response and user cancel as well as pagination, *)
(*            and formatted headings & footers.                       *)
(*                                                                    *)
(*  Source: F:\TP\UNIT\PRNUTIL.PAS                                    *)
(**********************************************************************)
Unit PrnUtil;

Interface

  Uses
    Dos,
    TPCRT,
    TPDate,
    Messages,
    TPString,
    IOError

    {$IFDEF NetPrint},
    DataEntry,
    NetWare
    {$ENDIF};

  const
    MaxLineLength = 132;                   { Max length of printable strings           }

    PrnDatePic : DateString = 'mm/dd/yy';  { Defines format of time in headers/footers }
    PrnTimePic : DateString = 'hh:mm te';  { Defines format of date in headers/footers }

  type
    PageLine = String[MaxLineLength];
    Justtype = (Left, Right, Middle);

  var
    PrnStatus,                   { Printer status.                            }
    PrnPort : Byte;              { Printer Port. 0 - LPT1, 1 - LPT2...        }
    PrnCanceled: Boolean;        { True if print was interrupted, will not
                                   print when this is true                    }
    PrintToFile : Boolean;       { True if printing to disk file - must be
                                   assigned & opened outside of this unit     }
    PrnIOResult : Word;          { I/O result when printing to disk file.     }
    PrnFile : Text;              { File to print to - must be assigned, and
                                   rewritten outside this unit.               }
    CurrLine : byte;             { Current line on page                       }
    CurrPage : Word;             { Current page number                        }

    { The following vars are initialized to reasonable values but may be      }
    { changed by calling program to customize behavior of this unit           }

    PageLength,                  { Number of lines/page                       }
    PageWidth : Byte;            { Number of columns/page                     }
    FootingLine : Byte;          { Line number to place footing on            }

    PrnInFileName : String[64];  { Used by Percent Expand for %F must be set  }
                                 { by calling program                         }

    PrnErrorAttr : Byte;         { Attribute for message windows              }

    {$IFDEF NetPrint}
    NetOK,                       { True if novell drivers initialized and  }
                                 { user is logged in                       }
    Capturing : boolean;         { True while printing is being spooled to }
                                 { a network printer                       }
    {$ENDIF}

  procedure Print(St : PageLine);
    {-Print a string to printer or disk file, No CRLF following }

  procedure PrintLn(St : PageLine);
    {-Print a string + CR + LF to printer or disk file }

  function PercentExpand( S: String ): String;
    {- Expand Headings and footers using embedded % commands. The
       following commands are implemented:

        %F - Replace with PrnInfileName which must be initialized by
             the calling program.
        %# - Replace with current page number.
        %T - Replace with system time (formatted by PrnTimePic).
        %D - Replace with system date (Formatted by PrnDatePic).
        %< - Left justify entire line.
        %> - Right justify entire line (dependent on PageWidth).
        %[ - Alternate Left justify Even/Odd pages
        %] - Alternate Right justify Even/Odd pages                  }


  procedure PrintJust(Line : PageLine;Just:Justtype);
    {-Print a justified or centered string }

  procedure PrnSkiplines(Num : Integer);
    {-Skip Num lines }

  procedure NewPage(Footer : PageLine);
    {-Advance to the top of the next page, printing Footer if desired}

  procedure PrnReset;
    {-Reset to page1, line1}

  procedure InitPrinter;
    {-Send reset to printer port.}

  function OpenPrnFile(FName: String): boolean;
    {-Open print file }

  function ClosePrnFile(FName: String): boolean;
    {-Close print file }

  {$IFDEF NetPrint}
  function SetCapture( On: boolean ): boolean;
    { Start or end capturing to a network printer }

  procedure SetPrintOptions;
    { Set network print options for local/network toggle and printer number }
  {$ENDIF}

Implementation

  const
    MaxPortNum  = 2;

    PrnTimeOut  = $01;
    PrnIOError  = $08;
    PrnOnLine   = $10;
    PrnOutPaper = $20;
    PrnACK      = $40;
    PrnNotBusy  = $80;


  function GetPortStatus( PortNo : byte ): byte;

    var
      Reg : registers;

    begin { GetPortStatus }
      if ( PortNo > MaxPortNum ) then     { Invalid port num }
         Exit;
      with Reg do
        begin
          AH := 2;
          DX := PortNo;
          Intr($17,Reg);
          GetPortStatus := AH
        end
    end;        { GetPortStatus }


  function PrinterOnLine( Status : Byte ) : Boolean;
   {-Checks PrnStatus to see if printer is ready }

    begin
      PrinterOnLine := (Status <> 0) And ((Status And
        (PrnTimeOut + PrnIOError + PrnOutPaper)) = 0);
    end;


  function Byte2Port( PortNum, TheByte : byte ) : byte;
    {-Send a byte to port PortNum (0..MaxPortNum) returns status byte }

    var
      Reg : registers;
      Stat : Byte;

    begin { Byte2Port }
      if (PortNum > MaxPortNum) then     { Invalid port num }
         Exit;
      repeat
        Stat := GetPortStatus( PortNum );
        if Not PrinterOnLine(Stat) then begin
          Byte2Port := Stat;
          exit
        end;
      until ((Stat and PrnNotBusy) <> 0);
      with Reg do
        begin
      AH := 0;
      AL := TheByte;
      DX := PortNum;
      Intr($17,Reg);
      Byte2Port := AH
        end
    end;    { Byte2Port }


  function InitPort( PortNum : byte ): byte;

    var
      Regs : registers;

    begin { InitPort }
      if (PortNum > MaxPortNum) then     { Invalid Port num }
         Exit;
      with Regs do
        begin
      AH := 1;
      DX := PortNum;
      Intr($17,Regs);
      InitPort := AH
        end
     end;    { InitPort }


  function StatusStr: String;
    {-Returns error message based on Status byte }

    const
      PStr = 'Printer';

    begin
      StatusStr := '';
      If ((PrnStatus And PrnIOError) <> 0) Then
        StatusStr := PStr + ' error';
      If ((PrnStatus And PrnACK) = 0) Then
        StatusStr := PStr + ' is not ready';
      If ((PrnStatus And PrnTimeOut) <> 0) Then
        StatusStr := PStr + ' is not ready';
      If ((PrnStatus And PrnNotBusy) = 0) Then
        StatusStr := PStr + ' is not ready';
      If ((PrnStatus And PrnOutPaper) <> 0) Then
        StatusStr := PStr + ' is out of paper';
      If ((PrnStatus And PrnOnLine) <> 0) Then
        StatusStr := PStr + ' is not responding';
    end;


  function PrnTimeOutCancel: Boolean;
    {-Pauses if printer error, cancels print if user enters ESC }

    const
      ReadyPrompt = 'Please ready printer or press ESC to exit';

    var
      Ch : Char;
      Savedvar : boolean;

    begin
      PrnTimeOutCancel := False;
      If PrinterOnLine( PrnStatus ) Then Exit;
      Savedvar := MsgDisposeCh;
      MsgDisposeCh := False;
      Message(TitleCmd+BeepCmd + LeaveCmd +' Printer Error '+TitleCmd +
                StatusStr + NewLnCmd + ReadyPrompt);
      repeat
        If KeyPressed Then
          Ch := ReadKey;
        PrnStatus := GetPortStatus( PrnPort );
      until PrinterOnLine( PrnStatus ) or (Ch = #27);
      RemoveMsg;
      if Ch = #27 Then
        PrnTimeOutCancel := True;
      MsgDisposeCh := Savedvar;
    end;


  function PrnUserCancel : Boolean;
    {-Pauses when user presses key, cancels if followed by ESC }

    const
      UserPausePrompt1 = 'Printing Paused.  Press ESC to cancel or';
      UserPausePrompt2 = 'any other key to resume...';

    var Ch : Char;
        OldCursor : Word;
        Savevar : boolean;

    begin
      PrnUserCancel := False;
      If Keypressed Then
       begin
         Ch := ReadKey;
         Savevar := MsgDisposeCh;
         MsgDisposeCh := False;
         Message(TitleCmd+BeepCmd + PauseCmd +' Printer ' + TitleCmd +
                 UserPausePrompt1 + NewLnCmd + UserPausePrompt2);
         Ch := ReadKey;
         MsgDisposeCh := Savevar;
         If Ch = #27 Then
           begin
             PrnUserCancel := True;
             PrnCanceled := True;
           end;
       end
    end;


  procedure CheckIOResult;
    {-Checks I/O result of printing to a disk file }
  begin
    PrnIOResult := IOResult;
    If PrnIOResult <> 0 Then
      PrnCanceled := True;
  end;


  function PrnCancel:Boolean;
    {-Checks printer and keyboard for any potential cancellation conditions }

    var
      Ok : byte;

    begin
      PrnCancel := False;
      If PrnCanceled Then
        begin
          PrnCancel := True;
          Exit;
        end;
      If PrnTimeOutCancel Then
        begin
          PrnCancel := True;
          PrnCanceled := True;
        end
      Else
        If KeyPressed And PrnUserCancel Then
           begin
             PrnCancel := True;
             PrnCanceled := True;
             If PrintToFile Then begin
                {$I-}
                Write(PrnFile,#12);
                {$I+}
                CheckIOResult;
              end
            Else begin
              PrnStatus := Byte2Port( PrnPort,12 ); { Sent FF to printer }

              {$IFDEF NetPrint}
              if NetOK And Capturing then begin
                Ok := CancelLPTCapture;
                if Ok <> 0 then
                  Message(TitleCmd+PauseCmd+' < Error >'+TitleCmd+
                          'Error canceling network print job.');
              end;
              {$ENDIF}

             end
           end
    end;


  procedure Print(St : PageLine);
    {-Print a string to printer or disk file }

    var
      I : Byte;

    begin
      If PrnCanceled Then Exit;
      PrnStatus := GetPortStatus( PrnPort );
      For I := 1 to Length(St) Do
        begin
          If PrnCancel Then Exit;
            If PrintToFile Then begin
              {$I-}
              Write(PrnFile,St[I]);
              {$I+}
              CheckIOResult;
            end
          Else
            PrnStatus := Byte2Port( PrnPort, Byte(St[I]) );
       end;
    end;


  procedure PrintLn(St : PageLine);
    {-Print a string + CR + LF to printer or disk file }

    const
      CRLF = #13#10;
    var
      I : Byte;

    begin
      If PrnCanceled Then Exit;
      Print(St);
      Print(CRLF);
      Inc(CurrLine);
      If CurrLine > PageLength Then
        begin
          CurrLine := 1;
          CurrPage := CurrPage+1;
        end;
    end;


  function PercentExpand( S: String ): String;
    {- Expand Headings            }
    var
      PE: String;
      I,CPN: Integer;
      PN: String[6];
      CurrJust : Justtype;

  begin
    CurrJust := Middle;
    PE := '';
    I := 1;
    while ( I<=Length(S) ) do
      begin
        if S[I]<>'%' then
          PE:=PE+S[I]
        else if I=Length(S) then
          PE:=PE+'%'
        else begin
          Case UpCase(S[I+1]) Of
             '#': begin                           { Insert Page Number      }
                    PN := Long2Str(CurrPage);
                    PE := PE+PN;
                  end;
             'T': PE := PE+CurrentTimeString(PrnTimePic);
                                                  { Insert Time             }
             'D': PE := PE+TodayString(PrnDatePic);
                                                  { Insert Date             }
             'F': PE := PE+PrnInFileName;         { Insert File Name        }
             '<': CurrJust := Left;               { Left Justify Heading    }
             '>': CurrJust := Right;              { Right Justify Heading   }
             '[': if Odd(CurrPage) then           { Alternate Left Even/Odd }
                     CurrJust := Left
                  else CurrJust := Right;
             ']': if Odd(CurrPage) then           { Alternate Right Even/Odd}
                    CurrJust := Right
                   else CurrJust := Left;
              else PE:=PE+S[I+1];                 { Don't recognize         }
          end; { Case S[I+1] }
            I := I+1;
        end; { Else S[I]='%' }
        I := I+1;
    end; { while }
    Case CurrJust of
      Middle : PE := Center (PE, PageWidth);
      Left   : PE := Pad    (PE, PageWidth);
      Right  : PE := LeftPad(PE,PageWidth);
    end; { Case }
    if Length(PE) > PageWidth then
      PE[0] := Chr(PageWidth);
    PercentExpand := PE;
  end; { PercentExpand }


  procedure PrintJust(Line : PageLine;Just:Justtype);
    {-Print a justified or centered string }
  var I : Byte;
  begin
    If PrnCanceled Then Exit;
    Case Just Of
      Middle : Println( Center (Line,PageWidth));
      Left   : Println( Pad    (Line,PageWidth));
      Right  : Println( LeftPad(Line,PageWidth));
    end
  end;


  procedure PrnSkiplines(Num : Integer);
    {-Skip Num lines }
  var I : Integer;
  begin
    If PrnCanceled Then Exit;
    For I := 1 To Num Do
      PrintLn('');
  end;

  procedure NewPage(Footer : PageLine);
    {-Advance to the top of the next page, printing Footer if desired}
  begin
    If PrnCanceled Then Exit;
    If (Footer = '') and (CurrLine = 1) then Exit;
    While Currline < FootingLine Do
      Println('');
    PrintLn( PercentExpand(Footer) );
    Repeat;
      PrintLn('')
    Until CurrLine = 1;
  end;


  procedure PrnReset;
    {-Reset to page1, line1}
  begin
    CurrPage := 1;
    CurrLine := 1;
    PrnCanceled := False;
  end;

  procedure InitPrinter;
    {-Send reset to PRN port}
  begin
    PrnStatus := InitPort( PrnPort );
  end;

  function OpenPrnFile(FName : String): boolean;

    var Result : Word;
        Ch : Char;
        Holdvar : Boolean;

    label Retry;

    begin
      OpenprnFile := False;
      PrintToFile := True;
      Holdvar := MsgDisposeCh;
      MsgDisposeCh := False;
     Retry:
      Assign(PrnFile,FNAme);
      {$I-}
      ReWrite(PrnFile);
      {$I+}
      Result := IOResult;
      If Result <> 0 Then
        begin
          Message(TitleCmd + BeepCmd + PauseCmd  + TitleCmd +
                  'Error: '+StUpCase(FName)+' - '+IOErrorMsg( Result ) +
                  NewLnCmd +
                  'Press ESC to Cancel, any other key to retry');
          Ch := Readkey;
          If Ch = #27 then
            begin
              PrnCanceled := True;
              PrintToFile := False;
              OpenPrnFile := False;
              MsgDisposeCh := Holdvar;
              Exit;
            end;
          Goto Retry;
        end
       else
         OpenPrnFile := True;
       MsgDisposeCh := Holdvar;
     end;

  function ClosePrnFile( FName: String ): boolean;

   var Ch : Char;
       Result : Word;

   label Retry;

   begin
     If PrnCanceled then Exit;
     PrintToFile := False;
   Retry:
     {$I-}
     Close(PrnFile);
     {$I+}
     Result := IOResult;
     If Result <> 0 Then
       begin
         Message(TitleCmd + BeepCmd + PauseCmd  + TitleCmd +
                 'Error: '+StUpCase(FName)+' - '+IOErrorMsg(Result) +
                 NewLnCmd +
                 'Press ESC to Cancel, any other key to retry');
         Ch := Readkey;
         If Ch = #27 then
           begin
             PrnCanceled := True;
             ClosePrnFile := False;
             Exit;
           end;
         Goto Retry;
       end
     else
       ClosePrnFile := True;
   end;

  {$IFDEF NetPrint}
  function SetCapture( On : Boolean ): boolean;

    begin
      if Not NetOk then
        exit;
      If On And ( StartLPTCapture = 0 ) then
        Capturing := True;
      If Not On And (endLPTCapture = 0) then
        Capturing := False;
      SetCapture := ( Capturing = On )
    end;

  procedure SetPrintOptions;

    var
      Job : PrintJobtype;
      SpoolNet : boolean;

    begin
      if Not NetOK then
        exit;
      GetPrintJobFlags( Job );
      SpoolNet := False;
      DefineField( 1, 'Spool to Network Printer: ',DE_Y, 1, 0, 0, 0, 1, @SpoolNet);
      DefineField( 2, '  Network Printer Number: ',DE_B,1, 0, 0, 2, 1, @Job.ServerPrinter);
      DefinedFlds := 2;
      if DataGet('Select Print Options (F2 when finished)', True, DefUsrFunc ) then
        begin
          SetPrintJobFlags( Job );
          if SpoolNet then begin
            if Capturing then
             if SetCapture( False ) then ;
            if Not SetCapture( True ) then
                Message(TitleCmd+PauseCmd+'< Error >'+TitleCmd+
                        'Unable to spool to network printer');
          end
        end
      else
        PrnCanceled := True;
      UndefineField(1);
      UndefineField(2);
      DefinedFlds := 0;
    end;

   var
     InitJob : PrintJobtype;
     LoggedIn : Boolean;
  {$ENDIF}

begin    { Initialize PrnUtil Unit }
   {$IFDEF NetPrint}
  if NetWareLoaded( LoggedIn ) then
    NetOK := LoggedIn
  else
    NetOk := False;
  if NetOK then begin
    GetPrintJobFlags( InitJob );
    if InitJob.Status=0 then
      Capturing := True;
  end;
  {$ENDIF}
  PrnIOResult := 0;
  PrintToFile := False;
  PrnPort := 0;
  PrnStatus := GetPortStatus( PrnPort );
  PageLength := 66;
  PageWidth := 80;
  FootingLine := PageLength - 1;
  PrnReset;
end.   { PrnUtil }